home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / warnings.pm < prev   
Text File  |  2008-07-24  |  13KB  |  380 lines
  1. # -*- buffer-read-only: t -*-
  2. # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
  3. # This file was created by warnings.pl
  4. # Any changes made here will be lost.
  5. #
  6.  
  7. package warnings;
  8.  
  9. our $VERSION = '1.06';
  10.  
  11. # Verify that we're called correctly so that warnings will work.
  12. # see also strict.pm.
  13. unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
  14.     my (undef, $f, $l) = caller;
  15.     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
  16. }
  17.  
  18. our %Offsets = (
  19.  
  20.     # Warnings Categories added in Perl 5.008
  21.  
  22.     'all'        => 0,
  23.     'closure'        => 2,
  24.     'deprecated'    => 4,
  25.     'exiting'        => 6,
  26.     'glob'        => 8,
  27.     'io'        => 10,
  28.     'closed'        => 12,
  29.     'exec'        => 14,
  30.     'layer'        => 16,
  31.     'newline'        => 18,
  32.     'pipe'        => 20,
  33.     'unopened'        => 22,
  34.     'misc'        => 24,
  35.     'numeric'        => 26,
  36.     'once'        => 28,
  37.     'overflow'        => 30,
  38.     'pack'        => 32,
  39.     'portable'        => 34,
  40.     'recursion'        => 36,
  41.     'redefine'        => 38,
  42.     'regexp'        => 40,
  43.     'severe'        => 42,
  44.     'debugging'        => 44,
  45.     'inplace'        => 46,
  46.     'internal'        => 48,
  47.     'malloc'        => 50,
  48.     'signal'        => 52,
  49.     'substr'        => 54,
  50.     'syntax'        => 56,
  51.     'ambiguous'        => 58,
  52.     'bareword'        => 60,
  53.     'digit'        => 62,
  54.     'parenthesis'    => 64,
  55.     'precedence'    => 66,
  56.     'printf'        => 68,
  57.     'prototype'        => 70,
  58.     'qw'        => 72,
  59.     'reserved'        => 74,
  60.     'semicolon'        => 76,
  61.     'taint'        => 78,
  62.     'threads'        => 80,
  63.     'uninitialized'    => 82,
  64.     'unpack'        => 84,
  65.     'untie'        => 86,
  66.     'utf8'        => 88,
  67.     'void'        => 90,
  68.   );
  69.  
  70. our %Bits = (
  71.     'all'        => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x05", # [0..45]
  72.     'ambiguous'        => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
  73.     'bareword'        => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
  74.     'closed'        => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
  75.     'closure'        => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
  76.     'debugging'        => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
  77.     'deprecated'    => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
  78.     'digit'        => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
  79.     'exec'        => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
  80.     'exiting'        => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
  81.     'glob'        => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
  82.     'inplace'        => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
  83.     'internal'        => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
  84.     'io'        => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
  85.     'layer'        => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
  86.     'malloc'        => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
  87.     'misc'        => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
  88.     'newline'        => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
  89.     'numeric'        => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
  90.     'once'        => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
  91.     'overflow'        => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
  92.     'pack'        => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
  93.     'parenthesis'    => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
  94.     'pipe'        => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
  95.     'portable'        => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
  96.     'precedence'    => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
  97.     'printf'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
  98.     'prototype'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
  99.     'qw'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
  100.     'recursion'        => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
  101.     'redefine'        => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
  102.     'regexp'        => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
  103.     'reserved'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
  104.     'semicolon'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
  105.     'severe'        => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
  106.     'signal'        => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
  107.     'substr'        => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
  108.     'syntax'        => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
  109.     'taint'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
  110.     'threads'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
  111.     'uninitialized'    => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
  112.     'unopened'        => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
  113.     'unpack'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
  114.     'untie'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
  115.     'utf8'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
  116.     'void'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
  117.   );
  118.  
  119. our %DeadBits = (
  120.     'all'        => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x0a", # [0..45]
  121.     'ambiguous'        => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
  122.     'bareword'        => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
  123.     'closed'        => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
  124.     'closure'        => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
  125.     'debugging'        => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
  126.     'deprecated'    => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
  127.     'digit'        => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
  128.     'exec'        => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
  129.     'exiting'        => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
  130.     'glob'        => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
  131.     'inplace'        => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
  132.     'internal'        => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
  133.     'io'        => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
  134.     'layer'        => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
  135.     'malloc'        => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
  136.     'misc'        => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
  137.     'newline'        => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
  138.     'numeric'        => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
  139.     'once'        => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
  140.     'overflow'        => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
  141.     'pack'        => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
  142.     'parenthesis'    => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
  143.     'pipe'        => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
  144.     'portable'        => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
  145.     'precedence'    => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
  146.     'printf'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
  147.     'prototype'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
  148.     'qw'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
  149.     'recursion'        => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
  150.     'redefine'        => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
  151.     'regexp'        => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
  152.     'reserved'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
  153.     'semicolon'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
  154.     'severe'        => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
  155.     'signal'        => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
  156.     'substr'        => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
  157.     'syntax'        => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
  158.     'taint'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
  159.     'threads'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
  160.     'uninitialized'    => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
  161.     'unopened'        => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
  162.     'unpack'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
  163.     'untie'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
  164.     'utf8'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
  165.     'void'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
  166.   );
  167.  
  168. $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
  169. $LAST_BIT = 92 ;
  170. $BYTES    = 12 ;
  171.  
  172. $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
  173.  
  174. sub Croaker
  175. {
  176.     require Carp::Heavy; # this initializes %CarpInternal
  177.     local $Carp::CarpInternal{'warnings'};
  178.     delete $Carp::CarpInternal{'warnings'};
  179.     Carp::croak(@_);
  180. }
  181.  
  182. sub bits
  183. {
  184.     # called from B::Deparse.pm
  185.  
  186.     push @_, 'all' unless @_;
  187.  
  188.     my $mask;
  189.     my $catmask ;
  190.     my $fatal = 0 ;
  191.     my $no_fatal = 0 ;
  192.  
  193.     foreach my $word ( @_ ) {
  194.     if ($word eq 'FATAL') {
  195.         $fatal = 1;
  196.         $no_fatal = 0;
  197.     }
  198.     elsif ($word eq 'NONFATAL') {
  199.         $fatal = 0;
  200.         $no_fatal = 1;
  201.     }
  202.     elsif ($catmask = $Bits{$word}) {
  203.         $mask |= $catmask ;
  204.         $mask |= $DeadBits{$word} if $fatal ;
  205.         $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
  206.     }
  207.     else
  208.           { Croaker("Unknown warnings category '$word'")}
  209.     }
  210.  
  211.     return $mask ;
  212. }
  213.  
  214. sub import 
  215. {
  216.     shift;
  217.  
  218.     my $catmask ;
  219.     my $fatal = 0 ;
  220.     my $no_fatal = 0 ;
  221.  
  222.     my $mask = ${^WARNING_BITS} ;
  223.  
  224.     if (vec($mask, $Offsets{'all'}, 1)) {
  225.         $mask |= $Bits{'all'} ;
  226.         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
  227.     }
  228.     
  229.     push @_, 'all' unless @_;
  230.  
  231.     foreach my $word ( @_ ) {
  232.     if ($word eq 'FATAL') {
  233.         $fatal = 1;
  234.         $no_fatal = 0;
  235.     }
  236.     elsif ($word eq 'NONFATAL') {
  237.         $fatal = 0;
  238.         $no_fatal = 1;
  239.     }
  240.     elsif ($catmask = $Bits{$word}) {
  241.         $mask |= $catmask ;
  242.         $mask |= $DeadBits{$word} if $fatal ;
  243.         $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
  244.     }
  245.     else
  246.           { Croaker("Unknown warnings category '$word'")}
  247.     }
  248.  
  249.     ${^WARNING_BITS} = $mask ;
  250. }
  251.  
  252. sub unimport 
  253. {
  254.     shift;
  255.  
  256.     my $catmask ;
  257.     my $mask = ${^WARNING_BITS} ;
  258.  
  259.     if (vec($mask, $Offsets{'all'}, 1)) {
  260.         $mask |= $Bits{'all'} ;
  261.         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
  262.     }
  263.  
  264.     push @_, 'all' unless @_;
  265.  
  266.     foreach my $word ( @_ ) {
  267.     if ($word eq 'FATAL') {
  268.         next; 
  269.     }
  270.     elsif ($catmask = $Bits{$word}) {
  271.         $mask &= ~($catmask | $DeadBits{$word} | $All);
  272.     }
  273.     else
  274.           { Croaker("Unknown warnings category '$word'")}
  275.     }
  276.  
  277.     ${^WARNING_BITS} = $mask ;
  278. }
  279.  
  280. my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
  281.  
  282. sub __chk
  283. {
  284.     my $category ;
  285.     my $offset ;
  286.     my $isobj = 0 ;
  287.  
  288.     if (@_) {
  289.         # check the category supplied.
  290.         $category = shift ;
  291.         if (my $type = ref $category) {
  292.             Croaker("not an object")
  293.                 if exists $builtin_type{$type};
  294.         $category = $type;
  295.             $isobj = 1 ;
  296.         }
  297.         $offset = $Offsets{$category};
  298.         Croaker("Unknown warnings category '$category'")
  299.         unless defined $offset;
  300.     }
  301.     else {
  302.         $category = (caller(1))[0] ;
  303.         $offset = $Offsets{$category};
  304.         Croaker("package '$category' not registered for warnings")
  305.         unless defined $offset ;
  306.     }
  307.  
  308.     my $this_pkg = (caller(1))[0] ;
  309.     my $i = 2 ;
  310.     my $pkg ;
  311.  
  312.     if ($isobj) {
  313.         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
  314.             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
  315.         }
  316.     $i -= 2 ;
  317.     }
  318.     else {
  319.         $i = _error_loc(); # see where Carp will allocate the error
  320.     }
  321.  
  322.     my $callers_bitmask = (caller($i))[9] ;
  323.     return ($callers_bitmask, $offset, $i) ;
  324. }
  325.  
  326. sub _error_loc {
  327.     require Carp::Heavy;
  328.     goto &Carp::short_error_loc; # don't introduce another stack frame
  329. }                                                             
  330.  
  331. sub enabled
  332. {
  333.     Croaker("Usage: warnings::enabled([category])")
  334.     unless @_ == 1 || @_ == 0 ;
  335.  
  336.     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
  337.  
  338.     return 0 unless defined $callers_bitmask ;
  339.     return vec($callers_bitmask, $offset, 1) ||
  340.            vec($callers_bitmask, $Offsets{'all'}, 1) ;
  341. }
  342.  
  343. sub warn
  344. {
  345.     Croaker("Usage: warnings::warn([category,] 'message')")
  346.     unless @_ == 2 || @_ == 1 ;
  347.  
  348.     my $message = pop ;
  349.     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
  350.     require Carp;
  351.     Carp::croak($message)
  352.     if vec($callers_bitmask, $offset+1, 1) ||
  353.        vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
  354.     Carp::carp($message) ;
  355. }
  356.  
  357. sub warnif
  358. {
  359.     Croaker("Usage: warnings::warnif([category,] 'message')")
  360.     unless @_ == 2 || @_ == 1 ;
  361.  
  362.     my $message = pop ;
  363.     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
  364.  
  365.     return
  366.         unless defined $callers_bitmask &&
  367.                 (vec($callers_bitmask, $offset, 1) ||
  368.                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
  369.  
  370.     require Carp;
  371.     Carp::croak($message)
  372.     if vec($callers_bitmask, $offset+1, 1) ||
  373.        vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
  374.  
  375.     Carp::carp($message) ;
  376. }
  377.  
  378. 1;
  379. # ex: set ro:
  380.